home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / language / harvest.cpt / Harvest C / Tcl 6.2 / tclUnixAZ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-04-22  |  44.1 KB  |  1,863 lines
  1. #ifdef macintosh
  2. #    pragma segment tclUnixAZ
  3. #endif
  4.  
  5. /* 
  6.  * tclUnixAZ.c --
  7.  *
  8.  *    This file contains the top-level command procedures for
  9.  *    commands in the Tcl core that require UNIX facilities
  10.  *    such as files and process execution.  Much of the code
  11.  *    in this file is based on earlier versions contributed
  12.  *    by Karl Lehenbauer, Mark Diekhans and Peter da Silva.
  13.  *
  14.  * Copyright 1991 Regents of the University of California
  15.  * Permission to use, copy, modify, and distribute this
  16.  * software and its documentation for any purpose and without
  17.  * fee is hereby granted, provided that this copyright
  18.  * notice appears in all copies.  The University of California
  19.  * makes no representations about the suitability of this
  20.  * software for any purpose.  It is provided "as is" without
  21.  * express or implied warranty.
  22.  */
  23.  
  24. #ifndef lint
  25. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUnixAZ.c,v 1.33 92/01/04 15:25:41 ouster Exp $ SPRITE (Berkeley)";
  26. #endif /* not lint */
  27.  
  28. #include "tclInt.h"
  29. #include "tclUnix.h"
  30.  
  31. #ifdef macintosh
  32.  
  33. #    include <Events.h>
  34.  
  35. #endif
  36.  
  37. /*
  38.  * The variable below caches the name of the current working directory
  39.  * in order to avoid repeated calls to getwd.  The string is malloc-ed.
  40.  * NULL means the cache needs to be refreshed.
  41.  */
  42.  
  43. static char *currentDir =  NULL;
  44.  
  45. /*
  46.  * Prototypes for local procedures defined in this file:
  47.  */
  48.  
  49. static int        CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
  50.                 int numPids, int *pidPtr, int errorId));
  51. static char *        GetFileType _ANSI_ARGS_((int mode));
  52. static int        StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
  53.                 char *varName, struct stat *statPtr));
  54.  
  55. /*
  56.  *----------------------------------------------------------------------
  57.  *
  58.  * Tcl_CdCmd --
  59.  *
  60.  *    This procedure is invoked to process the "cd" Tcl command.
  61.  *    See the user documentation for details on what it does.
  62.  *
  63.  * Results:
  64.  *    A standard Tcl result.
  65.  *
  66.  * Side effects:
  67.  *    See the user documentation.
  68.  *
  69.  *----------------------------------------------------------------------
  70.  */
  71.  
  72.     /* ARGSUSED */
  73. int
  74. Tcl_CdCmd(dummy, interp, argc, argv)
  75.     ClientData dummy;            /* Not used. */
  76.     Tcl_Interp *interp;            /* Current interpreter. */
  77.     int argc;                /* Number of arguments. */
  78.     char **argv;            /* Argument strings. */
  79. {
  80. #ifdef THINK_C
  81.     Tcl_AppendResult(interp, "chdir(2) not yet implemented for the MacOS", (char*)NULL);
  82.     return TCL_ERROR;
  83. #else /* !THINK_C */
  84.     char *dirName;
  85.  
  86.     if (argc > 2) {
  87.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  88.         " dirName\"", (char *) NULL);
  89.     return TCL_ERROR;
  90.     }
  91.  
  92.     if (argc == 2) {
  93.     dirName = argv[1];
  94.     } else {
  95.     dirName = "~";
  96.     }
  97.     dirName = Tcl_TildeSubst(interp, dirName);
  98.     if (dirName == NULL) {
  99.     return TCL_ERROR;
  100.     }
  101.     if (currentDir != NULL) {
  102.     ckfree(currentDir);
  103.     currentDir = NULL;
  104.     }
  105.     if (chdir(dirName) != 0) {
  106.     Tcl_AppendResult(interp, "couldn't change working directory to \"",
  107.         dirName, "\": ", Tcl_UnixError(interp), (char *) NULL);
  108.     return TCL_ERROR;
  109.     }
  110.     return TCL_OK;
  111. #endif
  112. }
  113.  
  114. /*
  115.  *----------------------------------------------------------------------
  116.  *
  117.  * Tcl_CloseCmd --
  118.  *
  119.  *    This procedure is invoked to process the "close" Tcl command.
  120.  *    See the user documentation for details on what it does.
  121.  *
  122.  * Results:
  123.  *    A standard Tcl result.
  124.  *
  125.  * Side effects:
  126.  *    See the user documentation.
  127.  *
  128.  *----------------------------------------------------------------------
  129.  */
  130.  
  131.     /* ARGSUSED */
  132. int
  133. Tcl_CloseCmd(dummy, interp, argc, argv)
  134.     ClientData dummy;            /* Not used. */
  135.     Tcl_Interp *interp;            /* Current interpreter. */
  136.     int argc;                /* Number of arguments. */
  137.     char **argv;            /* Argument strings. */
  138. {
  139.     OpenFile *filePtr;
  140.     int result = TCL_OK;
  141.  
  142.     if (argc != 2) {
  143.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  144.         " fileId\"", (char *) NULL);
  145.     return TCL_ERROR;
  146.     }
  147.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  148.     return TCL_ERROR;
  149.     }
  150.     ((Interp *) interp)->filePtrArray[fileno(filePtr->f)] = NULL;
  151.  
  152.     /*
  153.      * First close the file (in the case of a process pipeline, there may
  154.      * be two files, one for the pipe at each end of the pipeline).
  155.      */
  156.  
  157.     if (filePtr->f2 != NULL) {
  158.     if (fclose(filePtr->f2) == EOF) {
  159.         Tcl_AppendResult(interp, "error closing \"", argv[1],
  160.             "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
  161.         result = TCL_ERROR;
  162.     }
  163.     }
  164.     if (fclose(filePtr->f) == EOF) {
  165.     Tcl_AppendResult(interp, "error closing \"", argv[1],
  166.         "\": ", Tcl_UnixError(interp), "\n", (char *) NULL);
  167.     result = TCL_ERROR;
  168.     }
  169.  
  170.     /*
  171.      * If the file was a connection to a pipeline, clean up everything
  172.      * associated with the child processes.
  173.      */
  174.  
  175.     if (filePtr->numPids > 0) {
  176.     if (CleanupChildren(interp, filePtr->numPids, filePtr->pidPtr,
  177.         filePtr->errorId) != TCL_OK) {
  178.         result = TCL_ERROR;
  179.     }
  180.     }
  181.  
  182.     ckfree((char *) filePtr);
  183.     return result;
  184. }
  185.  
  186. /*
  187.  *----------------------------------------------------------------------
  188.  *
  189.  * Tcl_EofCmd --
  190.  *
  191.  *    This procedure is invoked to process the "eof" Tcl command.
  192.  *    See the user documentation for details on what it does.
  193.  *
  194.  * Results:
  195.  *    A standard Tcl result.
  196.  *
  197.  * Side effects:
  198.  *    See the user documentation.
  199.  *
  200.  *----------------------------------------------------------------------
  201.  */
  202.  
  203.     /* ARGSUSED */
  204. int
  205. Tcl_EofCmd(notUsed, interp, argc, argv)
  206.     ClientData notUsed;            /* Not used. */
  207.     Tcl_Interp *interp;            /* Current interpreter. */
  208.     int argc;                /* Number of arguments. */
  209.     char **argv;            /* Argument strings. */
  210. {
  211.     OpenFile *filePtr;
  212.  
  213.     if (argc != 2) {
  214.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  215.         " fileId\"", (char *) NULL);
  216.     return TCL_ERROR;
  217.     }
  218.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  219.     return TCL_ERROR;
  220.     }
  221.     if (feof(filePtr->f)) {
  222.     interp->result = "1";
  223.     } else {
  224.     interp->result = "0";
  225.     }
  226.     return TCL_OK;
  227. }
  228.  
  229. /*
  230.  *----------------------------------------------------------------------
  231.  *
  232.  * Tcl_ExecCmd --
  233.  *
  234.  *    This procedure is invoked to process the "exec" Tcl command.
  235.  *    See the user documentation for details on what it does.
  236.  *
  237.  * Results:
  238.  *    A standard Tcl result.
  239.  *
  240.  * Side effects:
  241.  *    See the user documentation.
  242.  *
  243.  *----------------------------------------------------------------------
  244.  */
  245.  
  246.     /* ARGSUSED */
  247. int
  248. Tcl_ExecCmd(dummy, interp, argc, argv)
  249.     ClientData dummy;            /* Not used. */
  250.     Tcl_Interp *interp;            /* Current interpreter. */
  251.     int argc;                /* Number of arguments. */
  252.     char **argv;            /* Argument strings. */
  253. {
  254.     int outputId;            /* File id for output pipe.  -1
  255.                      * means command overrode. */
  256.     int errorId;            /* File id for temporary file
  257.                      * containing error output. */
  258.     int *pidPtr;
  259.     int numPids, result;
  260.  
  261.     /*
  262.      * See if the command is to be run in background;  if so, create
  263.      * the command, detach it, and return.
  264.      */
  265.  
  266.     if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
  267.     argc--;
  268.     argv[argc] = NULL;
  269.     numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
  270.         (int *) NULL, (int *) NULL, (int *) NULL);
  271.     if (numPids < 0) {
  272.         return TCL_ERROR;
  273.     }
  274.     Tcl_DetachPids(numPids, pidPtr);
  275.     ckfree((char *) pidPtr);
  276.     return TCL_OK;
  277.     }
  278.  
  279.     /*
  280.      * Create the command's pipeline.
  281.      */
  282.  
  283.     numPids = Tcl_CreatePipeline(interp, argc-1, argv+1, &pidPtr,
  284.         (int *) NULL, &outputId, &errorId);
  285.     if (numPids < 0) {
  286.     return TCL_ERROR;
  287.     }
  288.  
  289.     /*
  290.      * Read the child's output (if any) and put it into the result.
  291.      */
  292.  
  293.     result = TCL_OK;
  294.     if (outputId != -1) {
  295.     while (1) {
  296. #        define BUFFER_SIZE 1000
  297.         char buffer[BUFFER_SIZE+1];
  298.         int count;
  299.     
  300.         count = read(outputId, buffer, BUFFER_SIZE);
  301.     
  302.         if (count == 0) {
  303.         break;
  304.         }
  305.         if (count < 0) {
  306.         Tcl_ResetResult(interp);
  307.         Tcl_AppendResult(interp,
  308.             "error reading from output pipe: ",
  309.             Tcl_UnixError(interp), (char *) NULL);
  310.         result = TCL_ERROR;
  311.         break;
  312.         }
  313.         buffer[count] = 0;
  314.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  315.     }
  316.     close(outputId);
  317.     }
  318.  
  319.     if (CleanupChildren(interp, numPids, pidPtr, errorId) != TCL_OK) {
  320.     result = TCL_ERROR;
  321.     }
  322.     return result;
  323. }
  324.  
  325. /*
  326.  *----------------------------------------------------------------------
  327.  *
  328.  * Tcl_ExitCmd --
  329.  *
  330.  *    This procedure is invoked to process the "exit" Tcl command.
  331.  *    See the user documentation for details on what it does.
  332.  *
  333.  * Results:
  334.  *    A standard Tcl result.
  335.  *
  336.  * Side effects:
  337.  *    See the user documentation.
  338.  *
  339.  *----------------------------------------------------------------------
  340.  */
  341.  
  342.     /* ARGSUSED */
  343. int
  344. Tcl_ExitCmd(dummy, interp, argc, argv)
  345.     ClientData dummy;            /* Not used. */
  346.     Tcl_Interp *interp;            /* Current interpreter. */
  347.     int argc;                /* Number of arguments. */
  348.     char **argv;            /* Argument strings. */
  349. {
  350.     int value;
  351.  
  352.     if ((argc != 1) && (argc != 2)) {
  353.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  354.         " ?returnCode?\"", (char *) NULL);
  355.     return TCL_ERROR;
  356.     }
  357.     if (argc == 1) {
  358.     exit(0);
  359.     }
  360.     if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
  361.     return TCL_ERROR;
  362.     }
  363.     exit(value);
  364.     return TCL_OK;            /* Better not ever reach this! */
  365. }
  366.  
  367. /*
  368.  *----------------------------------------------------------------------
  369.  *
  370.  * Tcl_FileCmd --
  371.  *
  372.  *    This procedure is invoked to process the "file" Tcl command.
  373.  *    See the user documentation for details on what it does.
  374.  *
  375.  * Results:
  376.  *    A standard Tcl result.
  377.  *
  378.  * Side effects:
  379.  *    See the user documentation.
  380.  *
  381.  *----------------------------------------------------------------------
  382.  */
  383.  
  384.     /* ARGSUSED */
  385. int
  386. Tcl_FileCmd(dummy, interp, argc, argv)
  387.     ClientData dummy;            /* Not used. */
  388.     Tcl_Interp *interp;            /* Current interpreter. */
  389.     int argc;                /* Number of arguments. */
  390.     char **argv;            /* Argument strings. */
  391. {
  392. char *p;
  393. int length, statOp, accessResult;
  394. int mode = 0;            /* Initialized only to prevent
  395.                  * compiler warning message. */
  396. struct stat statBuf;
  397. char *fileName, c;
  398.  
  399.     if (argc < 3) {
  400.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  401.                             " option name ?arg ...?\"", (char *) NULL);
  402.         return TCL_ERROR;
  403.         }
  404.     
  405.     c = argv[1][0];
  406.     length = strlen(argv[1]);
  407.  
  408.     /*
  409.      * First handle operations on the file name.
  410.      */
  411.  
  412.     fileName = Tcl_TildeSubst(interp, argv[2]);
  413.     if (fileName == NULL) {
  414.         return TCL_ERROR;
  415.         }
  416.     if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
  417.         if (argc != 3) {
  418.                 argv[1] = "dirname";
  419.                 not3Args:
  420.                     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  421.                                         " ", argv[1], " name\"", (char *) NULL);
  422.                 return TCL_ERROR;
  423.             }
  424. #ifdef macintosh
  425.         p = strrchr(fileName, ':');
  426. #else
  427.         p = strrchr(fileName, '/');
  428. #endif
  429.         if (p == NULL) {
  430. #ifdef macintosh
  431.             interp->result = "";
  432. #else
  433.             interp->result = ".";
  434. #endif
  435.             }
  436.         else if (p == fileName) {
  437. #ifdef macintosh
  438.             interp->result = "";
  439. #else
  440.             interp->result = "/";
  441. #endif
  442.             }
  443.         else {
  444.             *p = 0;
  445.             Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  446. #ifdef macintosh
  447.             *p = ':';
  448. #else
  449.             *p = '/';
  450. #endif
  451.             }
  452.         
  453.         return TCL_OK;
  454.         }
  455.     else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
  456.                 && (length >= 2))
  457.         {
  458.         char *lastSlash;
  459.     
  460.         if (argc != 3) {
  461.             argv[1] = "rootname";
  462.             goto not3Args;
  463.             }
  464.         p = strrchr(fileName, '.');
  465. #ifdef macintosh
  466.         lastSlash = strrchr(fileName, ':');
  467. #else
  468.         lastSlash = strrchr(fileName, '/');
  469. #endif
  470.         if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) {
  471.             Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  472.             }
  473.         else {
  474.             *p = 0;
  475.             Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  476.             *p = '.';
  477.             }
  478.         
  479.         return TCL_OK;
  480.         }
  481.     else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
  482.                 && (length >= 3))
  483.         {
  484.         char *lastSlash;
  485.     
  486.         if (argc != 3) {
  487.             argv[1] = "extension";
  488.             goto not3Args;
  489.             }
  490.         p = strrchr(fileName, '.');
  491. #ifdef macintosh
  492.         lastSlash = strrchr(fileName, ':');
  493. #else
  494.         lastSlash = strrchr(fileName, '/');
  495. #endif
  496.         if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) {
  497.             Tcl_SetResult(interp, p, TCL_VOLATILE);
  498.             }
  499.         
  500.         return TCL_OK;
  501.         }
  502.     else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)
  503.                     && (length >= 2))
  504.         {
  505.         if (argc != 3) {
  506.             argv[1] = "tail";
  507.             goto not3Args;
  508.             }
  509. #ifdef macintosh
  510.         p = strrchr(fileName, ':');
  511. #else
  512.         p = strrchr(fileName, '/');
  513. #endif
  514.         if (p != NULL) {
  515.             Tcl_SetResult(interp, p+1, TCL_VOLATILE);
  516.             }
  517.         else {
  518.             Tcl_SetResult(interp, fileName, TCL_VOLATILE);
  519.             }
  520.         return TCL_OK;
  521.         }
  522.  
  523.     /*
  524.      * Next, handle operations that can be satisfied with the "access"
  525.      * kernel call.
  526.      */
  527.  
  528.     if (fileName == NULL) {
  529.         return TCL_ERROR;
  530.         }
  531.     if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0)
  532.         && (length >= 5))
  533.         {
  534.         if (argc != 3) {
  535.             argv[1] = "readable";
  536.             goto not3Args;
  537.             }
  538.         mode = R_OK;
  539. checkAccess:
  540.         accessResult = access(fileName, mode);
  541.         if (accessResult == -1) {
  542.             interp->result = "0";
  543.             }
  544.         else {
  545.             interp->result = "1";
  546.             }
  547.         return TCL_OK;
  548.         }
  549.     else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) {
  550.         if (argc != 3) {
  551.             argv[1] = "writable";
  552.             goto not3Args;
  553.             }
  554.         mode = W_OK;
  555.         goto checkAccess;
  556.         }
  557.     else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0)
  558.                 && (length >= 3))
  559.         {
  560.         if (argc != 3) {
  561.             argv[1] = "executable";
  562.             goto not3Args;
  563.             }
  564.         mode = X_OK;
  565.         goto checkAccess;
  566.         }
  567.     else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)
  568.                 && (length >= 3)) 
  569.         {
  570.         if (argc != 3) {
  571.             argv[1] = "exists";
  572.             goto not3Args;
  573.             }
  574.         mode = F_OK;
  575.         goto checkAccess;
  576.         }
  577.  
  578.     /*
  579.      * Lastly, check stuff that requires the file to be stat-ed.
  580.      */
  581.  
  582.     if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) {
  583.         if (argc != 3) {
  584.             argv[1] = "atime";
  585.             goto not3Args;
  586.             }
  587.         if (stat(fileName, &statBuf) == -1) {
  588.             goto badStat;
  589.             }
  590.         sprintf(interp->result, "%lu", statBuf.st_atime);
  591.         return TCL_OK;
  592.         }
  593.     else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0)
  594.                 && (length >= 3))
  595.         {
  596.         if (argc != 3) {
  597.             argv[1] = "isdirectory";
  598.             goto not3Args;
  599.             }
  600.         statOp = 2;
  601.         }
  602.     else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0)
  603.             && (length >= 3))
  604.         {
  605.         if (argc != 3) {
  606.             argv[1] = "isfile";
  607.             goto not3Args;
  608.             }
  609.         statOp = 1;
  610.         }
  611.     else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) {
  612.         if (argc != 4) {
  613.             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  614.                 " lstat name varName\"", (char *) NULL);
  615.             return TCL_ERROR;
  616.             }
  617.     
  618.         if (lstat(fileName, &statBuf) == -1) {
  619.             Tcl_AppendResult(interp, "couldn't lstat \"", argv[2],
  620.                 "\": ", Tcl_UnixError(interp), (char *) NULL);
  621.             return TCL_ERROR;
  622.             }
  623.         return StoreStatData(interp, argv[3], &statBuf);
  624.         }
  625.     else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) {
  626.         if (argc != 3) {
  627.             argv[1] = "mtime";
  628.             goto not3Args;
  629.             }
  630.         if (stat(fileName, &statBuf) == -1) {
  631.             goto badStat;
  632.             }
  633.         sprintf(interp->result, "%lu", statBuf.st_mtime);
  634.         return TCL_OK;
  635.         }
  636.     else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) {
  637.         if (argc != 3) {
  638.             argv[1] = "owned";
  639.             goto not3Args;
  640.             }
  641.         statOp = 0;
  642. #ifdef S_IFLNK
  643.         /*
  644.          * This option is only included if symbolic links exist on this system
  645.          * (in which case S_IFLNK should be defined).
  646.          */
  647.         }
  648.     else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0)
  649.             && (length >= 5))
  650.         {
  651.         char linkValue[MAXPATHLEN+1];
  652.         int linkLength;
  653.     
  654.         if (argc != 3) {
  655.             argv[1] = "readlink";
  656.             goto not3Args;
  657.             }
  658.         linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
  659.         if (linkLength == -1) {
  660.             Tcl_AppendResult(interp, "couldn't readlink \"", argv[2],
  661.                 "\": ", Tcl_UnixError(interp), (char *) NULL);
  662.             return TCL_ERROR;
  663.             }
  664.         linkValue[linkLength] = 0;
  665.         Tcl_SetResult(interp, linkValue, TCL_VOLATILE);
  666.         return TCL_OK;
  667. #endif
  668.         }
  669.     else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  670.                 && (length >= 2))
  671.         {
  672.         if (argc != 3) {
  673.             argv[1] = "size";
  674.             goto not3Args;
  675.             }
  676.         if (stat(fileName, &statBuf) == -1) {
  677.             goto badStat;
  678.             }
  679.         sprintf(interp->result, "%lu", statBuf.st_size);
  680.         return TCL_OK;
  681.         }
  682.     else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0)
  683.                 && (length >= 2))
  684.         {
  685.         if (argc != 4) {
  686.             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  687.                 " stat name varName\"", (char *) NULL);
  688.             return TCL_ERROR;
  689.             }
  690.     
  691.         if (stat(fileName, &statBuf) == -1) {
  692.             badStat:
  693.             Tcl_AppendResult(interp, "couldn't stat \"", argv[2],
  694.                 "\": ", Tcl_UnixError(interp), (char *) NULL);
  695.             return TCL_ERROR;
  696.             }
  697.         return StoreStatData(interp, argv[3], &statBuf);
  698.         }
  699.     else if ((c == 't') && (strncmp(argv[1], "type", length) == 0)
  700.                    && (length >= 2))
  701.         {
  702.         if (argc != 3) {
  703.             argv[1] = "type";
  704.             goto not3Args;
  705.             }
  706.         if (lstat(fileName, &statBuf) == -1) {
  707.             goto badStat;
  708.             }
  709.         interp->result = GetFileType((int) statBuf.st_mode);
  710.         return TCL_OK;
  711.         }
  712.     else {
  713.         Tcl_AppendResult(interp, "bad option \"", argv[1],
  714.             "\": should be atime, dirname, executable, exists, ",
  715.             "extension, isdirectory, isfile, lstat, mtime, owned, ",
  716.             "readable, ",
  717. #ifdef S_IFLNK
  718.             "readlink, ",
  719. #endif
  720.             "root, size, stat, tail, type, ",
  721.             "or writable",
  722.             (char *) NULL);
  723.         return TCL_ERROR;
  724.         }
  725.     
  726.     if (stat(fileName, &statBuf) == -1) {
  727.         interp->result = "0";
  728.         return TCL_OK;
  729.         }
  730.     switch (statOp) {
  731.         case 0:
  732. #ifdef macintosh
  733.             mode = 1;
  734. #else
  735.             mode = (geteuid() == statBuf.st_uid);
  736. #endif
  737.  
  738.             break;
  739.         case 1:
  740.             mode = S_ISREG(statBuf.st_mode);
  741.             break;
  742.         case 2:
  743.             mode = S_ISDIR(statBuf.st_mode);
  744.             break;
  745.         }
  746.     if (mode) {
  747.         interp->result = "1";
  748.         }
  749.     else {
  750.         interp->result = "0";
  751.         }
  752.     return TCL_OK;
  753.     }
  754.  
  755. /*
  756.  *----------------------------------------------------------------------
  757.  *
  758.  * StoreStatData --
  759.  *
  760.  *    This is a utility procedure that breaks out the fields of a
  761.  *    "stat" structure and stores them in textual form into the
  762.  *    elements of an associative array.
  763.  *
  764.  * Results:
  765.  *    Returns a standard Tcl return value.  If an error occurs then
  766.  *    a message is left in interp->result.
  767.  *
  768.  * Side effects:
  769.  *    Elements of the associative array given by "varName" are modified.
  770.  *
  771.  *----------------------------------------------------------------------
  772.  */
  773.  
  774. static int
  775. StoreStatData(interp, varName, statPtr)
  776.     Tcl_Interp *interp;            /* Interpreter for error reports. */
  777.     char *varName;            /* Name of associative array variable
  778.                      * in which to store stat results. */
  779.     struct stat *statPtr;        /* Pointer to buffer containing
  780.                      * stat data to store in varName. */
  781. {
  782.     char string[30];
  783.  
  784.     sprintf(string, "%d", statPtr->st_dev);
  785.     if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
  786.         == NULL) {
  787.     return TCL_ERROR;
  788.     }
  789.     sprintf(string, "%d", statPtr->st_ino);
  790.     if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
  791.         == NULL) {
  792.     return TCL_ERROR;
  793.     }
  794.     sprintf(string, "%d", statPtr->st_mode);
  795.     if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
  796.         == NULL) {
  797.     return TCL_ERROR;
  798.     }
  799.     sprintf(string, "%d", statPtr->st_nlink);
  800.     if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
  801.         == NULL) {
  802.     return TCL_ERROR;
  803.     }
  804.     sprintf(string, "%d", statPtr->st_uid);
  805.     if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
  806.         == NULL) {
  807.     return TCL_ERROR;
  808.     }
  809.     sprintf(string, "%d", statPtr->st_gid);
  810.     if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
  811.         == NULL) {
  812.     return TCL_ERROR;
  813.     }
  814.     sprintf(string, "%lu", statPtr->st_size);
  815.     if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
  816.         == NULL) {
  817.     return TCL_ERROR;
  818.     }
  819.     sprintf(string, "%lu", statPtr->st_atime);
  820.     if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
  821.         == NULL) {
  822.     return TCL_ERROR;
  823.     }
  824.     sprintf(string, "%lu", statPtr->st_mtime);
  825.     if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
  826.         == NULL) {
  827.     return TCL_ERROR;
  828.     }
  829.     sprintf(string, "%lu", statPtr->st_ctime);
  830.     if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
  831.         == NULL) {
  832.     return TCL_ERROR;
  833.     }
  834.     if (Tcl_SetVar2(interp, varName, "type",
  835.         GetFileType((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
  836.     return TCL_ERROR;
  837.     }
  838.     return TCL_OK;
  839. }
  840.  
  841. /*
  842.  *----------------------------------------------------------------------
  843.  *
  844.  * GetFileType --
  845.  *
  846.  *    Given a mode word, returns a string identifying the type of a
  847.  *    file.
  848.  *
  849.  * Results:
  850.  *    A static text string giving the file type from mode.
  851.  *
  852.  * Side effects:
  853.  *    None.
  854.  *
  855.  *----------------------------------------------------------------------
  856.  */
  857.  
  858. static char *
  859. GetFileType(mode)
  860.     int mode;
  861. {
  862.     if (S_ISREG(mode)) {
  863.     return "file";
  864.     } else if (S_ISDIR(mode)) {
  865.     return "directory";
  866.     } else if (S_ISCHR(mode)) {
  867.     return "characterSpecial";
  868.     } else if (S_ISBLK(mode)) {
  869.     return "blockSpecial";
  870.     } else if (S_ISFIFO(mode)) {
  871.     return "fifo";
  872.     } else if (S_ISLNK(mode)) {
  873.     return "link";
  874.     } else if (S_ISSOCK(mode)) {
  875.     return "socket";
  876.     }
  877.     return "unknown";
  878. }
  879.  
  880. /*
  881.  *----------------------------------------------------------------------
  882.  *
  883.  * Tcl_FlushCmd --
  884.  *
  885.  *    This procedure is invoked to process the "flush" Tcl command.
  886.  *    See the user documentation for details on what it does.
  887.  *
  888.  * Results:
  889.  *    A standard Tcl result.
  890.  *
  891.  * Side effects:
  892.  *    See the user documentation.
  893.  *
  894.  *----------------------------------------------------------------------
  895.  */
  896.  
  897.     /* ARGSUSED */
  898. int
  899. Tcl_FlushCmd(notUsed, interp, argc, argv)
  900.     ClientData notUsed;            /* Not used. */
  901.     Tcl_Interp *interp;            /* Current interpreter. */
  902.     int argc;                /* Number of arguments. */
  903.     char **argv;            /* Argument strings. */
  904. {
  905.     OpenFile *filePtr;
  906.     FILE *f;
  907.  
  908.     if (argc != 2) {
  909.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  910.         " fileId\"", (char *) NULL);
  911.     return TCL_ERROR;
  912.     }
  913.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  914.     return TCL_ERROR;
  915.     }
  916.     if (!filePtr->writable) {
  917.     Tcl_AppendResult(interp, "\"", argv[1],
  918.         "\" wasn't opened for writing", (char *) NULL);
  919.     return TCL_ERROR;
  920.     }
  921.     f = filePtr->f2;
  922.     if (f == NULL) {
  923.     f = filePtr->f;
  924.     }
  925.     if (fflush(f) == EOF) {
  926.     Tcl_AppendResult(interp, "error flushing \"", argv[1],
  927.         "\": ", Tcl_UnixError(interp), (char *) NULL);
  928.     clearerr(f);
  929.     return TCL_ERROR;
  930.     }
  931.     return TCL_OK;
  932. }
  933.  
  934. /*
  935.  *----------------------------------------------------------------------
  936.  *
  937.  * Tcl_GetsCmd --
  938.  *
  939.  *    This procedure is invoked to process the "gets" Tcl command.
  940.  *    See the user documentation for details on what it does.
  941.  *
  942.  * Results:
  943.  *    A standard Tcl result.
  944.  *
  945.  * Side effects:
  946.  *    See the user documentation.
  947.  *
  948.  *----------------------------------------------------------------------
  949.  */
  950.  
  951.     /* ARGSUSED */
  952. int
  953. Tcl_GetsCmd(notUsed, interp, argc, argv)
  954.     ClientData notUsed;            /* Not used. */
  955.     Tcl_Interp *interp;            /* Current interpreter. */
  956.     int argc;                /* Number of arguments. */
  957.     char **argv;            /* Argument strings. */
  958. {
  959. #   define BUF_SIZE 200
  960.     char buffer[BUF_SIZE+1];
  961.     int totalCount, done, flags;
  962.     OpenFile *filePtr;
  963.     register FILE *f;
  964.  
  965.     if ((argc != 2) && (argc != 3)) {
  966.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  967.         " fileId ?varName?\"", (char *) NULL);
  968.     return TCL_ERROR;
  969.     }
  970.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  971.     return TCL_ERROR;
  972.     }
  973.     if (!filePtr->readable) {
  974.     Tcl_AppendResult(interp, "\"", argv[1],
  975.         "\" wasn't opened for reading", (char *) NULL);
  976.     return TCL_ERROR;
  977.     }
  978.  
  979.     /*
  980.      * We can't predict how large a line will be, so read it in
  981.      * pieces, appending to the current result or to a variable.
  982.      */
  983.  
  984.     totalCount = 0;
  985.     done = 0;
  986.     flags = 0;
  987.     f = filePtr->f;
  988.     while (!done) {
  989.     register int c, count;
  990.     register char *p;
  991.  
  992.     for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) {
  993.         c = getc(f);
  994.         if (c == EOF) {
  995.         if (ferror(filePtr->f)) {
  996.             Tcl_ResetResult(interp);
  997.             Tcl_AppendResult(interp, "error reading \"", argv[1],
  998.                 "\": ", Tcl_UnixError(interp), (char *) NULL);
  999.             clearerr(filePtr->f);
  1000.             return TCL_ERROR;
  1001.         } else if (feof(filePtr->f)) {
  1002.             if ((totalCount == 0) && (count == 0)) {
  1003.             totalCount = -1;
  1004.             }
  1005.             done = 1;
  1006.             break;
  1007.         }
  1008.         }
  1009.         if (c == '\n') {
  1010.         done = 1;
  1011.         break;
  1012.         }
  1013.         *p = c;
  1014.     }
  1015.     *p = 0;
  1016.     if (argc == 2) {
  1017.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  1018.     } else {
  1019.         Tcl_SetVar(interp, argv[2], buffer, flags);
  1020.         flags = TCL_APPEND_VALUE;
  1021.     }
  1022.     totalCount += count;
  1023.     }
  1024.  
  1025.     if (argc == 3) {
  1026.     sprintf(interp->result, "%d", totalCount);
  1027.     }
  1028.     return TCL_OK;
  1029. }
  1030.  
  1031. /*
  1032.  *----------------------------------------------------------------------
  1033.  *
  1034.  * Tcl_OpenCmd --
  1035.  *
  1036.  *    This procedure is invoked to process the "open" Tcl command.
  1037.  *    See the user documentation for details on what it does.
  1038.  *
  1039.  * Results:
  1040.  *    A standard Tcl result.
  1041.  *
  1042.  * Side effects:
  1043.  *    See the user documentation.
  1044.  *
  1045.  *----------------------------------------------------------------------
  1046.  */
  1047.  
  1048.     /* ARGSUSED */
  1049. int
  1050. Tcl_OpenCmd(notUsed, interp, argc, argv)
  1051.     ClientData notUsed;            /* Not used. */
  1052.     Tcl_Interp *interp;            /* Current interpreter. */
  1053.     int argc;                /* Number of arguments. */
  1054.     char **argv;            /* Argument strings. */
  1055. {
  1056.     Interp *iPtr = (Interp *) interp;
  1057.     int pipeline, fd;
  1058.     char *access;
  1059.     register OpenFile *filePtr;
  1060.  
  1061.     if (argc == 2) {
  1062.     access = "r";
  1063.     } else if (argc == 3) {
  1064.     access = argv[2];
  1065.     } else {
  1066.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1067.         " filename ?access?\"", (char *) NULL);
  1068.     return TCL_ERROR;
  1069.     }
  1070.  
  1071.     filePtr = (OpenFile *) ckalloc(sizeof(OpenFile));
  1072.     filePtr->f = NULL;
  1073.     filePtr->f2 = NULL;
  1074.     filePtr->readable = 0;
  1075.     filePtr->writable = 0;
  1076.     filePtr->numPids = 0;
  1077.     filePtr->pidPtr = NULL;
  1078.     filePtr->errorId = -1;
  1079.  
  1080.     /*
  1081.      * Verify the requested form of access.
  1082.      */
  1083.  
  1084.     pipeline = 0;
  1085.     if (argv[1][0] == '|') {
  1086.     pipeline = 1;
  1087.     }
  1088.     switch (access[0]) {
  1089.     case 'r':
  1090.         filePtr->readable = 1;
  1091.         break;
  1092.     case 'w':
  1093.         filePtr->writable = 1;
  1094.         break;
  1095.     case 'a':
  1096.         filePtr->writable = 1;
  1097.         break;
  1098.     default:
  1099.         badAccess:
  1100.         Tcl_AppendResult(interp, "illegal access mode \"", access,
  1101.             "\"", (char *) NULL);
  1102.         goto error;
  1103.     }
  1104.     if (access[1] == '+') {
  1105.     filePtr->readable = filePtr->writable = 1;
  1106.     if (access[2] != 0) {
  1107.         goto badAccess;
  1108.     }
  1109.     } else if (access[1] != 0) {
  1110.     goto badAccess;
  1111.     }
  1112.  
  1113.     /*
  1114.      * Open the file or create a process pipeline.
  1115.      */
  1116.  
  1117.     if (!pipeline) {
  1118.     char *fileName = argv[1];
  1119.  
  1120.     if (fileName[0] == '~') {
  1121.         fileName = Tcl_TildeSubst(interp, fileName);
  1122.         if (fileName == NULL) {
  1123.         goto error;
  1124.         }
  1125.     }
  1126.     filePtr->f = fopen(fileName, access);
  1127.     if (filePtr->f == NULL) {
  1128.         Tcl_AppendResult(interp, "couldn't open \"", argv[1],
  1129.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  1130.         goto error;
  1131.     }
  1132.     } else {
  1133.         Tcl_AppendResult(interp, "can not pipe in macintosh version", (char *) NULL);
  1134.         goto error;
  1135. #ifdef NEVER_DEFINED
  1136.         int *inPipePtr, *outPipePtr;
  1137.         int cmdArgc, inPipe, outPipe;
  1138.         char **cmdArgv;
  1139.     
  1140.         if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) {
  1141.             goto error;
  1142.             }
  1143.         inPipePtr = (filePtr->writable) ? &inPipe : NULL;
  1144.         outPipePtr = (filePtr->readable) ? &outPipe : NULL;
  1145.         inPipe = outPipe = -1;
  1146.         filePtr->numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv,
  1147.             &filePtr->pidPtr, inPipePtr, outPipePtr, &filePtr->errorId);
  1148.         ckfree((char *) cmdArgv);
  1149.         if (filePtr->numPids < 0) {
  1150.             goto error;
  1151.             }
  1152.         if (filePtr->readable) {
  1153.             if (outPipe == -1) {
  1154.                 if (inPipe != -1) {
  1155.                     close(inPipe);
  1156.                     }
  1157.                 Tcl_AppendResult(interp, "can't read output from command:",
  1158.                     " standard output was redirected", (char *) NULL);
  1159.                 goto error;
  1160.                 }
  1161.             filePtr->f = fdopen(outPipe, "r");
  1162.             }
  1163.         if (filePtr->writable) {
  1164.             if (inPipe == -1) {
  1165.                 Tcl_AppendResult(interp, "can't write input to command:",
  1166.                     " standard input was redirected", (char *) NULL);
  1167.                 goto error;
  1168.                 }
  1169.             if (filePtr->f != NULL) {
  1170.                 filePtr->f2 = fdopen(inPipe, "w");
  1171.                 }
  1172.             else {
  1173.                 filePtr->f = fdopen(inPipe, "w");
  1174.                 }
  1175.             }
  1176. #endif
  1177.         }
  1178.  
  1179.     /*
  1180.      * Enter this _new OpenFile structure in the table for the
  1181.      * interpreter.  May have to expand the table to do this.
  1182.      */
  1183.  
  1184.     fd = fileno(filePtr->f);
  1185.     TclMakeFileTable(iPtr, fd);
  1186.     if (iPtr->filePtrArray[fd] != NULL) {
  1187.     panic("Tcl_OpenCmd found file already open");
  1188.     }
  1189.     iPtr->filePtrArray[fd] = filePtr;
  1190.     sprintf(interp->result, "file%d", fd);
  1191.     return TCL_OK;
  1192.  
  1193.     error:
  1194.     if (filePtr->f != NULL) {
  1195.         fclose(filePtr->f);
  1196.         }
  1197.     if (filePtr->f2 != NULL) {
  1198.         fclose(filePtr->f2);
  1199.         }
  1200.     if (filePtr->numPids > 0) {
  1201.         Tcl_DetachPids(filePtr->numPids, filePtr->pidPtr);
  1202.         ckfree((char *) filePtr->pidPtr);
  1203.         }
  1204.     if (filePtr->errorId != -1) {
  1205.         close(filePtr->errorId);
  1206.         }
  1207.     ckfree((char *) filePtr);
  1208.     return TCL_ERROR;
  1209.     }
  1210.  
  1211. /*
  1212.  *----------------------------------------------------------------------
  1213.  *
  1214.  * Tcl_PwdCmd --
  1215.  *
  1216.  *    This procedure is invoked to process the "pwd" Tcl command.
  1217.  *    See the user documentation for details on what it does.
  1218.  *
  1219.  * Results:
  1220.  *    A standard Tcl result.
  1221.  *
  1222.  * Side effects:
  1223.  *    See the user documentation.
  1224.  *
  1225.  *----------------------------------------------------------------------
  1226.  */
  1227.  
  1228.     /* ARGSUSED */
  1229. int
  1230. Tcl_PwdCmd(dummy, interp, argc, argv)
  1231.     ClientData dummy;            /* Not used. */
  1232.     Tcl_Interp *interp;            /* Current interpreter. */
  1233.     int argc;                /* Number of arguments. */
  1234.     char **argv;            /* Argument strings. */
  1235. {
  1236. #ifdef NEVER_DEFINED
  1237.     char buffer[MAXPATHLEN+1];
  1238.  
  1239.     if (argc != 1) {
  1240.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1241.         argv[0], "\"", (char *) NULL);
  1242.     return TCL_ERROR;
  1243.     }
  1244.     if (currentDir == NULL) {
  1245. #if TCL_GETWD
  1246.     if (getwd(buffer) == NULL) {
  1247.         Tcl_AppendResult(interp, "error getting working directory name: ",
  1248.             buffer, (char *) NULL);
  1249.         return TCL_ERROR;
  1250.     }
  1251. #else
  1252.     if (getcwd(buffer, MAXPATHLEN) == NULL) {
  1253.         if (errno == ERANGE) {
  1254.         interp->result = "working directory name is too long";
  1255.         } else {
  1256.         Tcl_AppendResult(interp,
  1257.             "error getting working directory name: ",
  1258.             Tcl_UnixError(interp), (char *) NULL);
  1259.         }
  1260.         return TCL_ERROR;
  1261.     }
  1262. #endif
  1263.     currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1));
  1264.     strcpy(currentDir, buffer);
  1265.     }
  1266.     interp->result = currentDir;
  1267.     return TCL_OK;
  1268. #endif
  1269. }
  1270.  
  1271. /*
  1272.  *----------------------------------------------------------------------
  1273.  *
  1274.  * Tcl_PutsCmd --
  1275.  *
  1276.  *    This procedure is invoked to process the "puts" Tcl command.
  1277.  *    See the user documentation for details on what it does.
  1278.  *
  1279.  * Results:
  1280.  *    A standard Tcl result.
  1281.  *
  1282.  * Side effects:
  1283.  *    See the user documentation.
  1284.  *
  1285.  *----------------------------------------------------------------------
  1286.  */
  1287.  
  1288. typedef int (* PFI) () ;
  1289.  
  1290. static PFI    tcl_print_procedure = (PFI)0;
  1291.  
  1292. PFI
  1293. Tcl_SetPrintProcedure(proc)
  1294. PFI        proc;
  1295. {
  1296. PFI        result;
  1297.  
  1298.     result = tcl_print_procedure;
  1299.     tcl_print_procedure = proc;
  1300.     return result;
  1301.     }
  1302.  
  1303. PFI
  1304. Tcl_GetPrintProcedure()
  1305. {
  1306.     return tcl_print_procedure;
  1307.     }
  1308.  
  1309.     /* ARGSUSED */
  1310. int
  1311. Tcl_PutsCmd(dummy, interp, argc, argv)
  1312.     ClientData dummy;            /* Not used. */
  1313.     Tcl_Interp *interp;            /* Current interpreter. */
  1314.     int argc;                /* Number of arguments. */
  1315.     char **argv;            /* Argument strings. */
  1316. {
  1317.     OpenFile *filePtr;
  1318.     FILE *f;
  1319.  
  1320.     if (argc == 4) {
  1321.         if (strncmp(argv[3], "nonewline", strlen(argv[3])) != 0) {
  1322.             Tcl_AppendResult(interp, "bad argument \"", argv[3],
  1323.                     "\": should be \"nonewline\"", (char *) NULL);
  1324.             return TCL_ERROR;
  1325.             }
  1326.         }
  1327.     else if (argc != 3) {
  1328.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1329.             " fileId string ?nonewline?\"", (char *) NULL);
  1330.         return TCL_ERROR;
  1331.         }
  1332.     
  1333.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1334.         return TCL_ERROR;
  1335.         }
  1336.     if (!filePtr->writable) {
  1337.         Tcl_AppendResult(interp, "\"", argv[1],
  1338.             "\" wasn't opened for writing", (char *) NULL);
  1339.         return TCL_ERROR;
  1340.         }
  1341.  
  1342.     f = filePtr->f2;
  1343.     if (f == NULL) {
  1344.         f = filePtr->f;
  1345.         }
  1346.  
  1347.     if ( tcl_print_procedure != NULL &&
  1348.             (filePtr->f == stderr || filePtr->f == stdout) )
  1349.         {
  1350.         (* tcl_print_procedure)(argv[2]);
  1351.         if (argc == 3) {
  1352. #ifdef THINK_C
  1353.             (* tcl_print_procedure)("\r");
  1354. #else
  1355.             (* tcl_print_procedure)("\n");
  1356. #endif
  1357.             }
  1358.         }
  1359.     else {
  1360.         fputs(argv[2], f);
  1361.         if (argc == 3) {
  1362. #ifdef THINK_C
  1363.             fputc('\r', f);
  1364. #else
  1365.             fputc('\n', f);
  1366. #endif
  1367.             }
  1368.         }
  1369.     
  1370.     if (ferror(f)) {
  1371.         Tcl_AppendResult(interp, "error writing \"", argv[1],
  1372.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  1373.         clearerr(f);
  1374.         return TCL_ERROR;
  1375.         }
  1376.     
  1377.     return TCL_OK;
  1378.     }
  1379.  
  1380. /*
  1381.  *----------------------------------------------------------------------
  1382.  *
  1383.  * Tcl_ReadCmd --
  1384.  *
  1385.  *    This procedure is invoked to process the "read" Tcl command.
  1386.  *    See the user documentation for details on what it does.
  1387.  *
  1388.  * Results:
  1389.  *    A standard Tcl result.
  1390.  *
  1391.  * Side effects:
  1392.  *    See the user documentation.
  1393.  *
  1394.  *----------------------------------------------------------------------
  1395.  */
  1396.  
  1397.     /* ARGSUSED */
  1398. int
  1399. Tcl_ReadCmd(dummy, interp, argc, argv)
  1400.     ClientData dummy;            /* Not used. */
  1401.     Tcl_Interp *interp;            /* Current interpreter. */
  1402.     int argc;                /* Number of arguments. */
  1403.     char **argv;            /* Argument strings. */
  1404. {
  1405.     OpenFile *filePtr;
  1406.     int numBytes, count;
  1407.     struct stat statBuf;
  1408.     int newline;
  1409.  
  1410.     if ((argc != 2) && (argc != 3)) {
  1411.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1412.         " fileId ?numBytes|nonewline?\"", (char *) NULL);
  1413.     return TCL_ERROR;
  1414.     }
  1415.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1416.     return TCL_ERROR;
  1417.     }
  1418.     if (!filePtr->readable) {
  1419.     Tcl_AppendResult(interp, "\"", argv[1],
  1420.         "\" wasn't opened for reading", (char *) NULL);
  1421.     return TCL_ERROR;
  1422.     }
  1423.  
  1424.     /*
  1425.      * Compute how many bytes to read, and see whether the final
  1426.      * newline should be dropped.
  1427.      */
  1428.  
  1429.     newline = 1;
  1430.     if ((argc > 2) && isdigit(argv[2][0])) {
  1431.     if (Tcl_GetInt(interp, argv[2], &numBytes) != TCL_OK) {
  1432.         return TCL_ERROR;
  1433.     }
  1434.     } else {
  1435.  
  1436.     /*
  1437.      * Compute how many bytes are left in the file.  Try to read
  1438.      * one more byte than this, just to force the eof condition
  1439.      * to be seen.
  1440.      */
  1441.  
  1442.     if (fstat(fileno(filePtr->f), &statBuf) < 0) {
  1443.         Tcl_AppendResult(interp,
  1444.             "couldn't compute size of \"", argv[1],
  1445.             "\": ", Tcl_UnixError(interp), (char *) NULL);
  1446.         return TCL_ERROR;
  1447.     }
  1448.     numBytes = statBuf.st_size - ftell(filePtr->f) + 1;
  1449.     if (argc > 2) {
  1450.         if (strncmp(argv[2], "nonewline", strlen(argv[2])) == 0) {
  1451.         newline = 0;
  1452.         } else {
  1453.         Tcl_AppendResult(interp, "bad argument \"", argv[2],
  1454.             "\": should be \"nonewline\"", (char *) NULL);
  1455.         return TCL_ERROR;
  1456.         }
  1457.     }
  1458.     }
  1459.  
  1460.     /*
  1461.      * Read the bytes into a dynamically-allocated array, and
  1462.      * return it as result.
  1463.      */
  1464.  
  1465.     interp->result = (char *) ckalloc((unsigned) numBytes+1);
  1466.     interp->freeProc = (Tcl_FreeProc *) free;
  1467.     count = fread(interp->result, 1, numBytes, filePtr->f);
  1468.     if (ferror(filePtr->f)) {
  1469.     Tcl_ResetResult(interp);
  1470.     Tcl_AppendResult(interp, "error reading \"", argv[1],
  1471.         "\": ", Tcl_UnixError(interp), (char *) NULL);
  1472.     clearerr(filePtr->f);
  1473.     return TCL_ERROR;
  1474.     }
  1475.     if ((newline == 0) && (interp->result[count-1] == '\n')) {
  1476.     interp->result[count-1] = 0;
  1477.     } else {
  1478.     interp->result[count] = 0;
  1479.     }
  1480.     return TCL_OK;
  1481. }
  1482.  
  1483. /*
  1484.  *----------------------------------------------------------------------
  1485.  *
  1486.  * Tcl_SeekCmd --
  1487.  *
  1488.  *    This procedure is invoked to process the "seek" Tcl command.
  1489.  *    See the user documentation for details on what it does.
  1490.  *
  1491.  * Results:
  1492.  *    A standard Tcl result.
  1493.  *
  1494.  * Side effects:
  1495.  *    See the user documentation.
  1496.  *
  1497.  *----------------------------------------------------------------------
  1498.  */
  1499.  
  1500.     /* ARGSUSED */
  1501. int
  1502. Tcl_SeekCmd(notUsed, interp, argc, argv)
  1503.     ClientData notUsed;            /* Not used. */
  1504.     Tcl_Interp *interp;            /* Current interpreter. */
  1505.     int argc;                /* Number of arguments. */
  1506.     char **argv;            /* Argument strings. */
  1507. {
  1508.     OpenFile *filePtr;
  1509.     int offset, mode;
  1510.  
  1511.     if ((argc != 3) && (argc != 4)) {
  1512.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1513.         " fileId offset ?origin?\"", (char *) NULL);
  1514.     return TCL_ERROR;
  1515.     }
  1516.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1517.     return TCL_ERROR;
  1518.     }
  1519.     if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
  1520.     return TCL_ERROR;
  1521.     }
  1522.     mode = SEEK_SET;
  1523.     if (argc == 4) {
  1524.     int length;
  1525.     char c;
  1526.  
  1527.     length = strlen(argv[3]);
  1528.     c = argv[3][0];
  1529.     if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
  1530.         mode = SEEK_SET;
  1531.     } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
  1532.         mode = SEEK_CUR;
  1533.     } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
  1534.         mode = SEEK_END;
  1535.     } else {
  1536.         Tcl_AppendResult(interp, "bad origin \"", argv[3],
  1537.             "\": should be start, current, or end", (char *) NULL);
  1538.         return TCL_ERROR;
  1539.     }
  1540.     }
  1541.     if (fseek(filePtr->f, offset, mode) == -1) {
  1542.     Tcl_AppendResult(interp, "error during seek: ",
  1543.         Tcl_UnixError(interp), (char *) NULL);
  1544.     clearerr(filePtr->f);
  1545.     return TCL_ERROR;
  1546.     }
  1547.  
  1548.     return TCL_OK;
  1549. }
  1550.  
  1551. /*
  1552.  *----------------------------------------------------------------------
  1553.  *
  1554.  * Tcl_SourceCmd --
  1555.  *
  1556.  *    This procedure is invoked to process the "source" Tcl command.
  1557.  *    See the user documentation for details on what it does.
  1558.  *
  1559.  * Results:
  1560.  *    A standard Tcl result.
  1561.  *
  1562.  * Side effects:
  1563.  *    See the user documentation.
  1564.  *
  1565.  *----------------------------------------------------------------------
  1566.  */
  1567.  
  1568.     /* ARGSUSED */
  1569. int
  1570. Tcl_SourceCmd(dummy, interp, argc, argv)
  1571.     ClientData dummy;            /* Not used. */
  1572.     Tcl_Interp *interp;            /* Current interpreter. */
  1573.     int argc;                /* Number of arguments. */
  1574.     char **argv;            /* Argument strings. */
  1575. {
  1576.     if (argc != 2) {
  1577.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1578.         " fileName\"", (char *) NULL);
  1579.     return TCL_ERROR;
  1580.     }
  1581.     return Tcl_EvalFile(interp, argv[1]);
  1582. }
  1583.  
  1584. /*
  1585.  *----------------------------------------------------------------------
  1586.  *
  1587.  * Tcl_TellCmd --
  1588.  *
  1589.  *    This procedure is invoked to process the "tell" Tcl command.
  1590.  *    See the user documentation for details on what it does.
  1591.  *
  1592.  * Results:
  1593.  *    A standard Tcl result.
  1594.  *
  1595.  * Side effects:
  1596.  *    See the user documentation.
  1597.  *
  1598.  *----------------------------------------------------------------------
  1599.  */
  1600.  
  1601.     /* ARGSUSED */
  1602. int
  1603. Tcl_TellCmd(notUsed, interp, argc, argv)
  1604.     ClientData notUsed;            /* Not used. */
  1605.     Tcl_Interp *interp;            /* Current interpreter. */
  1606.     int argc;                /* Number of arguments. */
  1607.     char **argv;            /* Argument strings. */
  1608. {
  1609.     OpenFile *filePtr;
  1610.  
  1611.     if (argc != 2) {
  1612.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1613.         " fileId\"", (char *) NULL);
  1614.     return TCL_ERROR;
  1615.     }
  1616.     if (TclGetOpenFile(interp, argv[1], &filePtr) != TCL_OK) {
  1617.     return TCL_ERROR;
  1618.     }
  1619.     sprintf(interp->result, "%d", ftell(filePtr->f));
  1620.     return TCL_OK;
  1621. }
  1622.  
  1623. /*
  1624.  *----------------------------------------------------------------------
  1625.  *
  1626.  *   --
  1627.  *
  1628.  *    This procedure is invoked to process the "time" Tcl command.
  1629.  *    See the user documentation for details on what it does.
  1630.  *
  1631.  * Results:
  1632.  *    A standard Tcl result.
  1633.  *
  1634.  * Side effects:
  1635.  *    See the user documentation.
  1636.  *
  1637.  *----------------------------------------------------------------------
  1638.  */
  1639.  
  1640.     /* ARGSUSED */
  1641. int
  1642. Tcl_TimeCmd(dummy, interp, argc, argv)
  1643.     ClientData dummy;            /* Not used. */
  1644.     Tcl_Interp *interp;            /* Current interpreter. */
  1645.     int argc;                /* Number of arguments. */
  1646.     char **argv;            /* Argument strings. */
  1647. {
  1648.  
  1649.     int count, i, result;
  1650.     double timePer;
  1651. #ifdef macintosh
  1652.  
  1653.     unsigned long    start, stop;
  1654.  
  1655. #else
  1656.  
  1657. #if TCL_GETTOD
  1658.     struct timeval start, stop;
  1659.     struct timezone tz;
  1660.     int micros;
  1661. #else
  1662.     struct tms dummy2;
  1663.     long start, stop;
  1664.     long ticks;
  1665. #endif
  1666.  
  1667. #endif    /* macintosh */
  1668.  
  1669.     if (argc == 2) {
  1670.         count = 1;
  1671.         }
  1672.     else if (argc == 3) {
  1673.         if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
  1674.             return TCL_ERROR;
  1675.             }
  1676.         }
  1677.     else {
  1678.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1679.             " command ?count?\"", (char *) NULL);
  1680.         return TCL_ERROR;
  1681.         }
  1682. #ifdef macintosh
  1683.     start = TickCount();
  1684. #else
  1685. #if TCL_GETTOD
  1686.     gettimeofday(&start, &tz);
  1687. #else
  1688.     start = times(&dummy2);
  1689. #endif
  1690. #endif
  1691.     for (i = count ; i > 0; i--) {
  1692.         result = Tcl_Eval(interp, argv[1], 0, (char **) NULL);
  1693.         if (result != TCL_OK) {
  1694.             if (result == TCL_ERROR) {
  1695.                 char msg[60];
  1696.                 sprintf(msg, "\n    (\"time\" body line %d)",
  1697.                     interp->errorLine);
  1698.                 Tcl_AddErrorInfo(interp, msg);
  1699.                 }
  1700.             return result;
  1701.             }
  1702.         }
  1703. #ifdef macintosh
  1704.     stop = TickCount();
  1705.     timePer = ((double) (stop - start));
  1706. #else
  1707. #if TCL_GETTOD
  1708.     gettimeofday(&stop, &tz);
  1709.     micros = (stop.tv_sec - start.tv_sec)*1000000
  1710.         + (stop.tv_usec - start.tv_usec);
  1711.     timePer = micros;
  1712. #else
  1713.     stop = times(&dummy2);
  1714.     timePer = (((double) (stop - start))*1000000.0)/CLK_TCK;
  1715. #endif
  1716. #endif
  1717.     Tcl_ResetResult(interp);
  1718. #ifdef macintosh
  1719.     sprintf(interp->result, "%.0lf ticks per iteration", timePer / count);
  1720. #else
  1721.     sprintf(interp->result, "%.0lf microseconds per iteration", timePer/count);
  1722. #endif
  1723.     return TCL_OK;
  1724.  
  1725. }
  1726.  
  1727. /*
  1728.  *----------------------------------------------------------------------
  1729.  *
  1730.  * CleanupChildren --
  1731.  *
  1732.  *    This is a utility procedure used to wait for child processes
  1733.  *    to exit, record information about abnormal exits, and then
  1734.  *    collect any stderr output generated by them.
  1735.  *
  1736.  * Results:
  1737.  *    The return value is a standard Tcl result.  If anything at
  1738.  *    weird happened with the child processes, TCL_ERROR is returned
  1739.  *    and a message is left in interp->result.
  1740.  *
  1741.  * Side effects:
  1742.  *    If the last character of interp->result is a newline, then it
  1743.  *    is removed.  File errorId gets closed, and pidPtr is freed
  1744.  *    back to the storage allocator.
  1745.  *
  1746.  *----------------------------------------------------------------------
  1747.  */
  1748.  
  1749. static int
  1750. CleanupChildren(interp, numPids, pidPtr, errorId)
  1751.     Tcl_Interp *interp;        /* Used for error messages. */
  1752.     int numPids;        /* Number of entries in pidPtr array. */
  1753.     int *pidPtr;        /* Array of process ids of children. */
  1754.     int errorId;        /* File descriptor index for file containing
  1755.                  * stderr output from pipeline.  -1 means
  1756.                  * there isn't any stderr output. */
  1757. {
  1758.  
  1759. #ifdef macintosh
  1760.  
  1761.     Tcl_AppendResult(interp, " cleanup is unimplemented", (char *) NULL);
  1762.     return TCL_ERROR;
  1763.  
  1764. #else
  1765.  
  1766.     int result = TCL_OK;
  1767.     int i, pid, length;
  1768.     WAIT_STATUS_TYPE waitStatus;
  1769.  
  1770.     for (i = 0; i < numPids; i++) {
  1771.     pid = Tcl_WaitPids(1, &pidPtr[i], (int *) &waitStatus);
  1772.     if (pid == -1) {
  1773.         Tcl_AppendResult(interp, "error waiting for process to exit: ",
  1774.             Tcl_UnixError(interp), (char *) NULL);
  1775.         continue;
  1776.     }
  1777.  
  1778.     /*
  1779.      * Create error messages for unusual process exits.  An
  1780.      * extra newline gets appended to each error message, but
  1781.      * it gets removed below (in the same fashion that an
  1782.      * extra newline in the command's output is removed).
  1783.      */
  1784.  
  1785.     if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
  1786.         char msg1[20], msg2[20];
  1787.  
  1788.         result = TCL_ERROR;
  1789.         sprintf(msg1, "%d", pid);
  1790.         if (WIFEXITED(waitStatus)) {
  1791.         sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
  1792.         Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
  1793.             (char *) NULL);
  1794.         } else if (WIFSIGNALED(waitStatus)) {
  1795.         char *p;
  1796.     
  1797.         p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
  1798.         Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
  1799.             Tcl_SignalId((int) (WTERMSIG(waitStatus))), p,
  1800.             (char *) NULL);
  1801.         Tcl_AppendResult(interp, "child killed: ", p, "\n",
  1802.             (char *) NULL);
  1803.         } else if (WIFSTOPPED(waitStatus)) {
  1804.         char *p;
  1805.  
  1806.         p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
  1807.         Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
  1808.             Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL);
  1809.         Tcl_AppendResult(interp, "child suspended: ", p, "\n",
  1810.             (char *) NULL);
  1811.         } else {
  1812.         Tcl_AppendResult(interp,
  1813.             "child wait status didn't make sense\n",
  1814.             (char *) NULL);
  1815.         }
  1816.     }
  1817.     }
  1818.     ckfree((char *) pidPtr);
  1819.  
  1820.     /*
  1821.      * Read the standard error file.  If there's anything there,
  1822.      * then return an error and add the file's contents to the result
  1823.      * string.
  1824.      */
  1825.  
  1826.     if (errorId >= 0) {
  1827.     while (1) {
  1828. #        define BUFFER_SIZE 1000
  1829.         char buffer[BUFFER_SIZE+1];
  1830.         int count;
  1831.     
  1832.         count = read(errorId, buffer, BUFFER_SIZE);
  1833.     
  1834.         if (count == 0) {
  1835.         break;
  1836.         }
  1837.         if (count < 0) {
  1838.         Tcl_AppendResult(interp,
  1839.             "error reading stderr output file: ",
  1840.             Tcl_UnixError(interp), (char *) NULL);
  1841.         break;
  1842.         }
  1843.         buffer[count] = 0;
  1844.         Tcl_AppendResult(interp, buffer, (char *) NULL);
  1845.     }
  1846.     close(errorId);
  1847.     }
  1848.  
  1849.     /*
  1850.      * If the last character of interp->result is a newline, then remove
  1851.      * the newline character (the newline would just confuse things).
  1852.      */
  1853.  
  1854.     length = strlen(interp->result);
  1855.     if ((length > 0) && (interp->result[length-1] == '\n')) {
  1856.     interp->result[length-1] = '\0';
  1857.     }
  1858.  
  1859.     return result;
  1860.  
  1861. #endif
  1862. }
  1863.